Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/newusr32.fr_/newusr32.fr

Text File | 1995-09-04 | 6KB | 200 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Add User"
   ClientHeight    =   2760
   ClientLeft      =   1080
   ClientTop       =   1515
   ClientWidth     =   4980
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   3165
   Left            =   1020
   LinkTopic       =   "Form1"
   ScaleHeight     =   2760
   ScaleWidth      =   4980
   Top             =   1170
   Width           =   5100
   Begin VB.TextBox txtUserName
      Height          =   315
      Left            =   2160
      TabIndex        =   7
      Top             =   360
      Width           =   2115
   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "Cl&ose"
      Height          =   555
      Left            =   2520
      TabIndex        =   6
      Top             =   1920
      Width           =   1755
   End
   Begin VB.CommandButton cmdAddUser
      Caption         =   "&Add User"
      Default         =   -1  'True
      Height          =   555
      Left            =   480
      TabIndex        =   5
      Top             =   1920
      Width           =   1755
   End
   Begin VB.TextBox txtVerify
      Height          =   285
      Left            =   2160
      TabIndex        =   4
      Top             =   1320
      Width           =   2115
   End
   Begin VB.TextBox txtPassword
      Height          =   285
      Left            =   2160
      TabIndex        =   3
      Top             =   840
      Width           =   2115
   End
   Begin VB.Label Label4
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Retype to verify:"
      Height          =   195
      Left            =   540
      TabIndex        =   2
      Top             =   1380
      Width           =   1425
   End
   Begin VB.Label Label3
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Password:"
      Height          =   195
      Left            =   1050
      TabIndex        =   1
      Top             =   900
      Width           =   885
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "&User name:"
      Height          =   195
      Left            =   900
      TabIndex        =   0
      Top             =   420
      Width           =   975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetPrivateProfileString _
    Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpSectionName As String, _
    ByVal lpKeyName As Any, ByVal lpDefault As String, _
    ByVal lpReturnedString As String, ByVal Size As Integer, _
    ByVal lpFileName As String) As Integer


Private Sub Form_Load()
    Dim myUser As String, myPass As String
    Dim winDir As String * 128
    Dim dirLen As Integer

    On Error GoTo LoadError

    ' Set the user and passwords for initial login.
    myUser = "Admin"
    myPass = "theboss"

    ' read VBDBHT.INI to get the name of the system database,
    ' then assign that name to the SystemDB property
    DBEngine.SystemDB = GetSystemDatabase()

    ' log in
    DBEngine.DefaultUser = myUser
    DBEngine.DefaultPassword = myPass

Exit Sub
LoadError:
    MsgBox Err & " " & Error$
End

End Sub


Private Sub cmdAddUser_Click()
    Dim newUser As User
    Dim thePID As String

    On Error GoTo ChangeError

    If txtUserName = "" Then Error 32765
    If txtPassword <> "" And txtPassword <> txtVerify Then Error 32767
    If Len(txtPassword) > 14 Then Error 32766
    thePID = txtUserName
    If Len(thePID) > 20 Then
        thePID = Left$(thePID, 20)
    Else
        Do While Len(thePID) < 4
            thePID = thePID & "_"
        Loop
    End If
    Set newUser = DBEngine.Workspaces(0).CreateUser(txtUserName, thePID, txtPassword)
    DBEngine.Workspaces(0).Users.Append newUser
    MsgBox "User " & txtUserName & " created", vbInformation
    txtUserName = ""
    txtPassword = ""
    txtVerify = ""
Exit Sub
ChangeError:
    Dim msg As String
    Select Case Err.Number
        Case 3390
            msg = "There is already a user with that name in the system database"
        Case 32765
            msg = "You have not selected a user"
        Case 32766
            msg = "The password may not be longer than 14 characters"
            txtPassword = ""
            txtVerify = ""
        Case 32767
            msg = "The verify box does not match the password box"
            txtPassword = ""
            txtVerify = ""
        Case Else
            msg = Err.Description & " (" & Err.Number & ")"
    End Select
    MsgBox msg, vbExclamation
End Sub

Private Sub cmdClose_Click()
    End
End Sub

Private Function GetSystemDatabase() As String
    ' Returns the name of the system directory

    Const INI_FILENAME = "VBDBHT.INI"
    Const MAX_PATH = 128

    Dim lpReturnedString As String * MAX_PATH
    Dim bytesBack As Integer

    bytesBack = GetPrivateProfileString("Options", _
        "SystemDB", "", lpReturnedString, MAX_PATH, INI_FILENAME)
    GetSystemDatabase = IIf(bytesBack > 0, Left$(lpReturnedString, bytesBack), "")

End Function